home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / cpl.lsp < prev    next >
Text File  |  1992-07-09  |  12KB  |  316 lines
  1. ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; compute-class-precedence-list
  32. ;;;
  33. ;;; Knuth section 2.2.3 has some interesting notes on this.
  34. ;;; 
  35. ;;; What appears here is basically the algorithm presented there.
  36. ;;;
  37. ;;; The key idea is that we use class-precedence-description (CPD) structures
  38. ;;; to store the precedence information as we proceed.  The CPD structure for
  39. ;;; a class stores two critical pieces of information:
  40. ;;; 
  41. ;;;  - a count of the number of "reasons" why the class can't go
  42. ;;;    into the class precedence list yet.
  43. ;;;    
  44. ;;;  - a list of the "reasons" this class prevents others from
  45. ;;;    going in until after it
  46. ;;
  47. ;;; A "reason" is essentially a single local precedence constraint.  If a
  48. ;;; constraint between two classes arises more than once it generates more
  49. ;;; than one reason.  This makes things simpler, linear, and isn't a problem
  50. ;;; as long as we make sure to keep track of each instance of a "reason".
  51. ;;;
  52. ;;; This code is divided into three phases.
  53. ;;; 
  54. ;;;  - the first phase simply generates the CPD's for each of the class
  55. ;;;    and its superclasses.  The remainder of the code will manipulate
  56. ;;;    these CPDs rather than the class objects themselves.  At the end
  57. ;;;    of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
  58. ;;;    of the direct superclasses of the class.
  59. ;;;
  60. ;;;  - the second phase folds all the local constraints into the CPD
  61. ;;;    structure.  The CPD-COUNT of each CPD is built up, and the
  62. ;;;    CPD-AFTER fields are augmented to include precedence constraints
  63. ;;;    from the CPD-SUPERS field and from the order of classes in other
  64. ;;;    CPD-SUPERS fields.
  65. ;;;
  66. ;;;    After this phase, the CPD-AFTER field of a class includes all the
  67. ;;;    direct superclasses of the class plus any class that immediately
  68. ;;;    follows the class in the direct superclasses of another.  There
  69. ;;;    can be duplicates in this list.  The CPD-COUNT field is equal to
  70. ;;;    the number of times this class appears in the CPD-AFTER field of
  71. ;;;    all the other CPDs.
  72. ;;;
  73. ;;;  - In the third phase, classes are put into the precedence list one
  74. ;;;    at a time, with only those classes with a CPD-COUNT of 0 being
  75. ;;;    candidates for insertion.  When a class is inserted , every CPD
  76. ;;;    in its CPD-AFTER field has its count decremented.
  77. ;;;
  78. ;;;    In the usual case, there is only one candidate for insertion at
  79. ;;;    any point.  If there is more than one, the specified tiebreaker
  80. ;;;    rule is used to choose among them.
  81. ;;;    
  82.  
  83. (defmethod compute-class-precedence-list ((root slot-class))
  84.   (compute-std-cpl root (class-direct-superclasses root)))
  85.  
  86. (defstruct (class-precedence-description
  87.          (:conc-name nil)
  88.          (:print-function (lambda (obj str depth)
  89.                 (declare (ignore depth))
  90.                 (format str
  91.                     "#<CPD ~S ~D>"
  92.                     (class-name (cpd-class obj))
  93.                     (cpd-count obj))))
  94.          (:constructor make-cpd ()))
  95.   (cpd-class  nil)
  96.   (cpd-supers ())
  97.   (cpd-after  ())
  98.   (cpd-count  0 :type fixnum))
  99.  
  100. (defun compute-std-cpl (class supers)
  101.   (cond ((null supers)                ;First two branches of COND
  102.      (list class))                ;are implementing the single
  103.     ((null (cdr supers))            ;inheritance optimization.
  104.      (cons class
  105.            (compute-std-cpl (car supers)
  106.                 (class-direct-superclasses (car supers)))))
  107.     (t
  108.      (multiple-value-bind (all-cpds nclasses)
  109.          (compute-std-cpl-phase-1 class supers)
  110.        (compute-std-cpl-phase-2 all-cpds)
  111.        (compute-std-cpl-phase-3 class all-cpds nclasses)))))
  112.  
  113. (defvar *compute-std-cpl-class->entry-table-size* 60)
  114.  
  115. (declaim (ftype (function (T T) (values list index)) compute-std-cpl-phase-1))
  116. (defun compute-std-cpl-phase-1 (class supers)
  117.   (let ((nclasses 0)
  118.     (all-cpds ())
  119.     (table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
  120.                 :test #'eq)))
  121.     (declare (type index nclasses))
  122.     (labels ((get-cpd (c)
  123.            (or (gethash c table)
  124.            (setf (gethash c table) (make-cpd))))
  125.          (walk (c supers)
  126.            (if (forward-referenced-class-p c)
  127.            (cpl-forward-referenced-class-error class c)
  128.            (let ((cpd (get-cpd c)))
  129.              (unless (cpd-class cpd)    ;If we have already done this
  130.                         ;class before, we can quit.
  131.                (setf (cpd-class cpd) c)
  132.                (incf nclasses)
  133.                (push cpd all-cpds)
  134.                (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
  135.                (dolist (super supers)
  136.              (walk super (class-direct-superclasses super))))))))
  137.       (walk class supers)
  138.       (values all-cpds nclasses))))
  139.  
  140. (defun compute-std-cpl-phase-2 (all-cpds)
  141.   (dolist (cpd all-cpds)
  142.     (let ((supers (cpd-supers cpd)))
  143.       (when supers
  144.     (setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
  145.     (incf (cpd-count (car supers)) 1)
  146.     (do* ((t1 supers t2)
  147.           (t2 (cdr t1) (cdr t1)))
  148.          ((null t2))
  149.       (incf (cpd-count (car t2)) 2)
  150.       (push (car t2) (cpd-after (car t1))))))))
  151.  
  152. (defun compute-std-cpl-phase-3 (class all-cpds nclasses)
  153.   (declare (type index nclasses))
  154.   (let ((candidates ())
  155.     (next-cpd nil)
  156.     (rcpl ()))
  157.     ;;
  158.     ;; We have to bootstrap the collection of those CPD's that
  159.     ;; have a zero count.  Once we get going, we will maintain
  160.     ;; this list incrementally.
  161.     ;; 
  162.     (dolist (cpd all-cpds)
  163.       (when (zerop (cpd-count cpd)) (push cpd candidates)))
  164.  
  165.     
  166.     (loop
  167.       (when (null candidates)
  168.     ;;
  169.     ;; If there are no candidates, and enough classes have been put
  170.     ;; into the precedence list, then we are all done.  Otherwise
  171.     ;; it means there is a consistency problem.
  172.     (if (zerop nclasses)
  173.         (return (reverse rcpl))
  174.         (cpl-inconsistent-error class all-cpds)))
  175.       ;;
  176.       ;; Try to find the next class to put in from among the candidates.
  177.       ;; If there is only one, its easy, otherwise we have to use the
  178.       ;; famous RPG tiebreaker rule.  There is some hair here to avoid
  179.       ;; having to call DELETE on the list of candidates.  I dunno if
  180.       ;; its worth it but what the hell.
  181.       ;; 
  182.       (setq next-cpd
  183.         (if (null (cdr candidates))
  184.         (prog1 (car candidates)
  185.                (setq candidates ()))
  186.         (block tie-breaker              
  187.           (dolist (c rcpl)
  188.             (let ((supers (class-direct-superclasses c)))
  189.               (if (memq (cpd-class (car candidates)) supers)
  190.               (return-from tie-breaker (pop candidates))
  191.               (do ((loc candidates (cdr loc)))
  192.                   ((null (cdr loc)))
  193.                 (let ((cpd (cadr loc)))
  194.                   (when (memq (cpd-class cpd) supers)
  195.                 (setf (cdr loc) (cddr loc))
  196.                 (return-from tie-breaker cpd))))))))))
  197.       (decf nclasses)
  198.       (push (cpd-class next-cpd) rcpl)
  199.       (dolist (after (cpd-after next-cpd))
  200.     (when (zerop (the fixnum (decf (cpd-count after))))
  201.       (push after candidates))))))
  202.  
  203. ;;;
  204. ;;; Support code for signalling nice error messages.
  205. ;;;
  206.  
  207. (defun cpl-error (class format-string &rest format-args)
  208.   (error "While computing the class precedence list of the class ~A.~%~A"
  209.       (if (class-name class)
  210.           (format nil "named ~S" (class-name class))
  211.